home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / ice-9 / occam-channel.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  7.3 KB  |  263 lines
  1. ;;;; Occam-like channels
  2.  
  3. ;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
  4. ;;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;; 
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19. (define-module (ice-9 occam-channel)
  20.   #:use-syntax (ice-9 syncase)
  21.   #:use-module (oop goops)
  22.   #:use-module (ice-9 threads)
  23.   #:export-syntax (alt
  24.            ;; macro use:
  25.            oc:lock oc:unlock oc:consequence
  26.            oc:immediate-dispatch oc:late-dispatch oc:first-channel
  27.            oc:set-handshake-channel oc:unset-handshake-channel)
  28.   #:export (make-channel
  29.         ?
  30.         !
  31.         make-timer
  32.         ;; macro use:
  33.         handshake-channel mutex
  34.         sender-waiting?
  35.         immediate-receive late-receive
  36.         )
  37.   )
  38.  
  39. (define no-data '(no-data))
  40. (define receiver-waiting '(receiver-waiting))
  41.  
  42. (define-class <channel> ())
  43.  
  44. (define-class <data-channel> (<channel>)
  45.   (handshake-channel #:accessor handshake-channel)
  46.   (data #:accessor data #:init-value no-data)
  47.   (cv #:accessor cv #:init-form (make-condition-variable))
  48.   (mutex #:accessor mutex #:init-form (make-mutex)))
  49.  
  50. (define-method (initialize (ch <data-channel>) initargs)
  51.   (next-method)
  52.   (set! (handshake-channel ch) ch))
  53.  
  54. (define-method (make-channel)
  55.   (make <data-channel>))
  56.  
  57. (define-method (sender-waiting? (ch <data-channel>))
  58.   (not (eq? (data ch) no-data)))
  59.  
  60. (define-method (receiver-waiting? (ch <data-channel>))
  61.   (eq? (data ch) receiver-waiting))
  62.  
  63. (define-method (immediate-receive (ch <data-channel>))
  64.   (signal-condition-variable (cv ch))
  65.   (let ((res (data ch)))
  66.     (set! (data ch) no-data)
  67.     res))
  68.  
  69. (define-method (late-receive (ch <data-channel>))
  70.   (let ((res (data ch)))
  71.     (set! (data ch) no-data)
  72.     res))
  73.  
  74. (define-method (? (ch <data-channel>))
  75.   (lock-mutex (mutex ch))
  76.   (let ((res (cond ((receiver-waiting? ch)
  77.             (unlock-mutex (mutex ch))
  78.             (scm-error 'misc-error '?
  79.                    "another process is already receiving on ~A"
  80.                    (list ch) #f))
  81.            ((sender-waiting? ch)
  82.             (immediate-receive ch))
  83.            (else
  84.             (set! (data ch) receiver-waiting)
  85.             (wait-condition-variable (cv ch) (mutex ch))
  86.             (late-receive ch)))))
  87.     (unlock-mutex (mutex ch))
  88.     res))
  89.  
  90. (define-method (! (ch <data-channel>))
  91.   (! ch *unspecified*))
  92.  
  93. (define-method (! (ch <data-channel>) (x <top>))
  94.   (lock-mutex (mutex (handshake-channel ch)))
  95.   (cond ((receiver-waiting? ch)
  96.      (set! (data ch) x)
  97.      (signal-condition-variable (cv (handshake-channel ch))))
  98.     ((sender-waiting? ch)
  99.      (unlock-mutex (mutex (handshake-channel ch)))
  100.      (scm-error 'misc-error '! "another process is already sending on ~A"
  101.             (list ch) #f))
  102.     (else
  103.      (set! (data ch) x)
  104.      (wait-condition-variable (cv ch) (mutex ch))))
  105.   (unlock-mutex (mutex (handshake-channel ch))))
  106.  
  107. ;;; Add protocols?
  108.  
  109. (define-class <port-channel> (<channel>)
  110.   (port #:accessor port #:init-keyword #:port))
  111.  
  112. (define-method (make-channel (port <port>))
  113.   (make <port-channel> #:port port))
  114.  
  115. (define-method (? (ch <port-channel>))
  116.   (read (port ch)))
  117.  
  118. (define-method (! (ch <port-channel>))
  119.   (write (port ch)))
  120.  
  121. (define-class <timer-channel> (<channel>))
  122.  
  123. (define the-timer (make <timer-channel>))
  124.  
  125. (define timer-cv (make-condition-variable))
  126. (define timer-mutex (make-mutex))
  127.  
  128. (define (make-timer)
  129.   the-timer)
  130.  
  131. (define (timeofday->us t)
  132.   (+ (* 1000000 (car t)) (cdr t)))
  133.  
  134. (define (us->timeofday n)
  135.   (cons (quotient n 1000000)
  136.     (remainder n 1000000)))
  137.  
  138. (define-method (? (ch <timer-channel>))
  139.   (timeofday->us (gettimeofday)))
  140.  
  141. (define-method (? (ch <timer-channel>) (t <integer>))
  142.   (lock-mutex timer-mutex)
  143.   (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
  144.   (unlock-mutex timer-mutex))
  145.  
  146. ;;; (alt CLAUSE ...)
  147. ;;;
  148. ;;; CLAUSE ::= ((? CH) FORM ...)
  149. ;;;            | (EXP (? CH) FORM ...)
  150. ;;;            | (EXP FORM ...)
  151. ;;;
  152. ;;; where FORM ... can be => (lambda (x) ...)
  153. ;;;
  154. ;;; *fixme* Currently only handles <data-channel>:s
  155. ;;;
  156.  
  157. (define-syntax oc:lock
  158.   (syntax-rules (?)
  159.     ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
  160.     ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
  161.     ((_ (exp form ...)) #f)))
  162.  
  163. (define-syntax oc:unlock
  164.   (syntax-rules (?)
  165.     ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
  166.     ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
  167.     ((_ (exp form ...)) #f)))
  168.  
  169. (define-syntax oc:consequence
  170.   (syntax-rules (=>)
  171.     ((_ data) data)
  172.     ((_ data => (lambda (x) e1 e2 ...))
  173.      (let ((x data)) e1 e2 ...))
  174.     ((_ data e1 e2 ...)
  175.      (begin data e1 e2 ...))))
  176.  
  177. (define-syntax oc:immediate-dispatch
  178.   (syntax-rules (?)
  179.     ((_ ((? ch) e1 ...))
  180.      ((sender-waiting? ch)
  181.       (oc:consequence (immediate-receive ch) e1 ...)))
  182.     ((_ (exp (? ch) e1 ...))
  183.      ((and exp (sender-waiting? ch))
  184.       (oc:consequence (immediate-receive ch) e1 ...)))
  185.     ((_ (exp e1 ...))
  186.      (exp e1 ...))))
  187.  
  188. (define-syntax oc:late-dispatch
  189.   (syntax-rules (?)
  190.     ((_ ((? ch) e1 ...))
  191.      ((sender-waiting? ch)
  192.       (oc:consequence (late-receive ch) e1 ...)))
  193.     ((_ (exp (? ch) e1 ...))
  194.      ((and exp (sender-waiting? ch))
  195.       (oc:consequence (late-receive ch) e1 ...)))
  196.     ((_ (exp e1 ...))
  197.      (#f))))
  198.  
  199. (define-syntax oc:first-channel
  200.   (syntax-rules (?)
  201.     ((_ ((? ch) e1 ...) c2 ...)
  202.      ch)
  203.     ((_ (exp (? ch) e1 ...) c2 ...)
  204.      ch)
  205.     ((_ c1 c2 ...)
  206.      (first-channel c2 ...))))
  207.  
  208. (define-syntax oc:set-handshake-channel
  209.   (syntax-rules (?)
  210.     ((_ ((? ch) e1 ...) handshake)
  211.      (set! (handshake-channel ch) handshake))
  212.     ((_ (exp (? ch) e1 ...) handshake)
  213.      (and exp (set! (handshake-channel ch) handshake)))
  214.     ((_ (exp e1 ...) handshake)
  215.      #f)))
  216.  
  217. (define-syntax oc:unset-handshake-channel
  218.   (syntax-rules (?)
  219.     ((_ ((? ch) e1 ...))
  220.      (set! (handshake-channel ch) ch))
  221.     ((_ (exp (? ch) e1 ...))
  222.      (and exp (set! (handshake-channel ch) ch)))
  223.     ((_ (exp e1 ...))
  224.      #f)))
  225.  
  226. (define-syntax alt
  227.   (lambda (x)
  228.     (define (else-clause? x)
  229.       (syntax-case x (else)
  230.     ((_) #f)
  231.     ((_ (else e1 e2 ...)) #t)
  232.     ((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))
  233.     
  234.     (syntax-case x (else)
  235.       ((_ c1 c2 ...)
  236.        (else-clause? x)
  237.        (syntax (begin
  238.          (oc:lock c1)
  239.          (oc:lock c2) ...
  240.          (let ((res (cond (oc:immediate-dispatch c1)
  241.                   (oc:immediate-dispatch c2) ...)))
  242.            (oc:unlock c1)
  243.            (oc:unlock c2) ...
  244.            res))))
  245.       ((_ c1 c2 ...)
  246.        (syntax (begin
  247.          (oc:lock c1)
  248.          (oc:lock c2) ...
  249.          (let ((res (cond (oc:immediate-dispatch c1)
  250.                   (oc:immediate-dispatch c2) ...
  251.                   (else (let ((ch (oc:first-channel c1 c2 ...)))
  252.                       (oc:set-handshake-channel c1 ch)
  253.                       (oc:set-handshake-channel c2 ch) ...
  254.                       (wait-condition-variable (cv ch)
  255.                                    (mutex ch))
  256.                       (oc:unset-handshake-channel c1)
  257.                       (oc:unset-handshake-channel c2) ...
  258.                       (cond (oc:late-dispatch c1)
  259.                         (oc:late-dispatch c2) ...))))))
  260.            (oc:unlock c1)
  261.            (oc:unlock c2) ...
  262.            res)))))))
  263.